home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: New Zealand Amiga Users Group / New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).zip / New Zealand Amiga Users Group Newsdisk v03 (1987-02)(NZAmigaUG).adf / BASIC / ScapeGen16a < prev    next >
Text File  |  1993-12-02  |  3KB  |  80 lines
  1. REM   FRACTAL LANDSCAPES with SOLID SURFACE  by G Thornton
  2.       
  3.       CLEAR ,50000&
  4.       SCREEN 1,640,200,4,2
  5.       WINDOW 2,"Fractal landscapes Mk II [hit <RETURN> to exit]",,0,1
  6.       RANDOMIZE TIMER: COLOR 2,10
  7.       DIM d%(128,128)
  8.       FOR i=0 TO 15:READ r,g,b:PALETTE i,r/15,g/15,b/15:NEXT
  9.       DATA 11,6,6,0,7,15,13,12,8,6,12,6,5,10,0,0,8,5,0,7,0,3,5,0,5,5,4
  10.       DATA 5,4,0,6,5,0,7,6,5,8,7,6,8,8,8,11,11,11,15,15,15
  11.       water=-200:sea=1
  12. 30    INPUT "Number of levels <1-7> ";le: IF le < 1 OR le > 7 THEN 30
  13.       INPUT "Variable smoothness (Y/N) ";smoo$
  14.       IF LEFT$(UCASE$(smoo$),1)="Y" THEN hill=1 ELSE hill=0 
  15. 40    IF hill=0 THEN INPUT "Enter smoothness (1.5-2.5) :",Sm
  16.       mx=2^le
  17. 50    pi=3.14159:my=mx/2
  18. 60    FOR n=1 TO le:IF hill=0 THEN L=15000/Sm^n
  19. 70    PRINT : PRINT  "Working on level ";n
  20. 80    ib=mx/2^n:sk=ib*2
  21. 90    GOSUB 150: ' *** Assign heights along X in array ***
  22. 100   GOSUB 220: ' *** Assign heights along Y in array ***
  23. 110   GOSUB 290: ' *** Assign heights along diag. in array ***
  24. 120   NEXT n
  25.       IF sea=0 THEN 130
  26.       FOR i=0 TO mx :FOR j=0 TO mx
  27.         IF d%(i,j)<water THEN d%(i,j)=water ELSE IF d%(i,j)>maxz THEN maxz=d%(i,j)
  28.       NEXT j,i  
  29. 130   GOTO 640:  ' *** Draw ***
  30.     ' *** Heights along x ***
  31. 150 FOR ye = 0 TO mx  STEP sk
  32.     IF hill=1 THEN L=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
  33.     FOR xe = ib TO mx STEP sk
  34.     d%(xe,ye)=(d%(xe-ib,ye)+d%(xe+ib,ye))/2 + RND*L/2-L/4
  35.     NEXT xe
  36.     NEXT ye: RETURN
  37.    ' *** Heights along Y ***
  38. 220 FOR ye = ib TO mx STEP sk
  39.     IF hill=1 THEN L=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
  40.     FOR xe = 0 TO mx STEP sk
  41.     d%(xe,ye)=(d%(xe,ye-ib)+d%(xe,ye+ib))/2+ RND*L/2-L/4
  42.     NEXT xe
  43.     NEXT ye: RETURN
  44.     ' *** Heights along diag. ***
  45. 290 sq2=SQR(2)
  46.     FOR ye = ib TO mx  STEP sk
  47.     IF hill=1 THEN L=15000/(1.3+le/20+(ye/mx*(.8-le/20)))^n
  48.     FOR xe = ib TO mx  STEP sk
  49.     d%(xe,ye)=(d%(xe-ib,ye+ib)+d%(xe+ib,ye-ib))/2+ RND*L/sq2-L/2/sq2
  50.     NEXT xe
  51.     NEXT ye: RETURN
  52. 630   ' **** Display here ****
  53. 640   GOSUB 1100: ' *** Set up plotting device or screen ***
  54.     xa=55/mx/mx: ys = 120/mx: yc=50: zs=yc/maxz*.85:' *** scaling factors ***
  55.     FOR ay = 0 TO mx-1 :ays=ay*ys+yc:xs=(550+55*ay/mx)/mx
  56.     FOR ax = 0 TO mx-1 :axs=ax*xs:ax1=axs+xs
  57.     z1=d%(ax,ay):z2=d%(ax,ay+1):z3=d%(ax+1,ay)
  58.     GOSUB Tricolour :ay2=ays+ys-z2*zs:ay3=ays-z3*zs
  59.     AREA(axs,ays-z1*zs):AREA(axs+xa*ax,ay2):AREA(ax1,ay3):AREAFILL
  60.     z1=d%(ax+1,ay+1):GOSUB Tricolour
  61.     AREA(ax1+xa*(ax+1),ays+ys-z1*zs):AREA(axs,ay2):AREA(ax1,ay3):AREAFILL
  62.     NEXT ax,ay
  63. 750   GOTO 1130: ' *** done plotting, goto end loop ***
  64.  
  65. Tricolour: height=(z1+z2+z3)/3 - water
  66.   IF height<10 THEN COLOR 1:RETURN
  67.   hi=INT(height/maxz*14+1+RND*.5):IF hi>14 THEN hi=14
  68.   COLOR 1+hi
  69.   RETURN
  70.   
  71. 1100  ' * * * setup plotting device or screen * * *
  72. 1110  CLS: LINE (0,0)-(620,190),0,bf: RETURN
  73. 1120  ' *** End loop ***
  74. 1130  '
  75. 1140  INPUT "",E$
  76.       SCREEN CLOSE 1
  77.       END
  78.  
  79.                      
  80.